home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / lzhpas.zip / LZH.PAS next >
Pascal/Delphi Source File  |  1993-04-01  |  20KB  |  852 lines
  1. unit lzh;
  2. {$A+,B-,D+,E-,F-,I+,L+,N-,O+,R-,S-,V-}
  3. (*
  4.  * LZHUF.C English version 1.0
  5.  * Based on Japanese version 29-NOV-1988
  6.  * LZSS coded by Haruhiko OKUMURA
  7.  * Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
  8.  * Edited and translated to English by Kenji RIKITAKE
  9.  * Translated from C to Turbo Pascal by Douglas Webb   2/18/91
  10.  *)
  11.  
  12. {
  13.      This unit allows the user to commpress data using a combination of
  14.    LZSS compression and adaptive Huffman coding, or conversely to decompress
  15.    data that was previously compressed by this unit.
  16.  
  17.      There are a number of options as to where the data being compressed/
  18.    decompressed is coming from/going to.
  19.  
  20.     In fact it requires that you pass the "LZHPack" procedure 2 procedural
  21.   parameter of type 'GetProcType' and 'PutProcType' (declared below) which
  22.   will accept 3 parameters and act in every way like a 'BlockRead'/'BlockWrite'
  23.   procedure call. Your 'GetProcType' procedure should return the data
  24.   to be compressed, and Your 'PutProcType' procedure should do something with
  25.   the compressed data (ie., put it in a file).  In case you need to know (and
  26.   you do if you want to decompress this data again) the number of bytes in the
  27.   compressed data (original, not compressed size) is returned in 'Bytes_Written'.
  28.  
  29.   GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  30.   
  31.   DTA is the start of a memory location where the information returned should
  32.   be.  NBytes is the number of bytes requested.  The actual number of bytes
  33.   returned must be passed in Bytes_Got (if there is no more data then 0
  34.   should be returned).
  35.  
  36.   PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  37.  
  38.   As above except instead of asking for data the procedure is dumping out
  39.   compressed data, do somthing with it.
  40.  
  41.  
  42.     "LZHUnPack" is basically the same thing in reverse.  It requires
  43.   procedural parameters of type 'PutProcType'/'GetProcType' which
  44.   will act as above.  'GetProcType' must retrieve data compressed using
  45.   "LZHPack" (above) and feed it to the unpacking routine as requested.
  46.   'PutProcType' must accept the decompressed data and do something
  47.   withit.  You must also pass in the original size of the decompressed data,
  48.   failure to do so will have adverse results.
  49.  
  50.  
  51.      Don't forget that as procedural parameters the 'GetProcType'/'PutProcType'
  52.   procedures must be compiled in the 'F+' state to avoid a catastrophe.
  53.  
  54.  
  55.  
  56. }
  57.  
  58. { Note: All the large data structures for these routines are allocated when
  59.   needed from the heap, and deallocated when finished.  So when not in use
  60.   memory requirements are minimal.  However, this unit uses about 34K of
  61.   heap space, and 400 bytes of stack when in use. }
  62.  
  63.  
  64. interface
  65.  
  66. TYPE
  67.  
  68.  
  69.   PutBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Put : WORD);
  70.   GetBytesProc = PROCEDURE(VAR DTA; NBytes:WORD; VAR Bytes_Got : WORD);
  71.  
  72.  
  73.  
  74. Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
  75. Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
  76.  
  77.  
  78.  
  79.  
  80. implementation
  81.  
  82. CONST
  83.   EXIT_OK = 0;
  84.   EXIT_FAILED = 1;
  85. { LZSS Parameters }
  86.   N        = 4096;    { Size of string buffer }
  87.   F        = 60;    { Size of look-ahead buffer }
  88.   THRESHOLD    = 2;
  89.   NUL        = N;    { End of tree's node  }
  90.   N_CHAR   =    (256 - THRESHOLD + F);
  91.         { character code (:= 0..N_CHAR-1) }
  92.   T        =    (N_CHAR * 2 - 1);    { Size of table }
  93.   R        =    (T - 1);        { root position }
  94.   MAX_FREQ =    $8000;
  95.                     { update when cumulative frequency }
  96.                     { reaches to this value }
  97. {
  98.  * Tables FOR encoding/decoding upper 6 bits of
  99.  * sliding dictionary pointer
  100.  }
  101. { encoder table }
  102.   p_len : Array[0..63] of BYTE =
  103.        ($03, $04, $04, $04, $05, $05, $05, $05,
  104.     $05, $05, $05, $05, $06, $06, $06, $06,
  105.     $06, $06, $06, $06, $06, $06, $06, $06,
  106.     $07, $07, $07, $07, $07, $07, $07, $07,
  107.     $07, $07, $07, $07, $07, $07, $07, $07,
  108.     $07, $07, $07, $07, $07, $07, $07, $07,
  109.     $08, $08, $08, $08, $08, $08, $08, $08,
  110.     $08, $08, $08, $08, $08, $08, $08, $08);
  111.  
  112.   p_code : Array [0..63] OF BYTE =
  113.        ($00, $20, $30, $40, $50, $58, $60, $68,
  114.     $70, $78, $80, $88, $90, $94, $98, $9C,
  115.     $A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
  116.     $C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
  117.     $D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
  118.     $E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
  119.     $F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
  120.     $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);
  121.  
  122. { decoder table }
  123.   d_code: Array [0..255] OF BYTE =
  124.        ($00, $00, $00, $00, $00, $00, $00, $00,
  125.     $00, $00, $00, $00, $00, $00, $00, $00,
  126.     $00, $00, $00, $00, $00, $00, $00, $00,
  127.     $00, $00, $00, $00, $00, $00, $00, $00,
  128.     $01, $01, $01, $01, $01, $01, $01, $01,
  129.     $01, $01, $01, $01, $01, $01, $01, $01,
  130.     $02, $02, $02, $02, $02, $02, $02, $02,
  131.     $02, $02, $02, $02, $02, $02, $02, $02,
  132.     $03, $03, $03, $03, $03, $03, $03, $03,
  133.     $03, $03, $03, $03, $03, $03, $03, $03,
  134.     $04, $04, $04, $04, $04, $04, $04, $04,
  135.     $05, $05, $05, $05, $05, $05, $05, $05,
  136.     $06, $06, $06, $06, $06, $06, $06, $06,
  137.     $07, $07, $07, $07, $07, $07, $07, $07,
  138.     $08, $08, $08, $08, $08, $08, $08, $08,
  139.     $09, $09, $09, $09, $09, $09, $09, $09,
  140.     $0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A,
  141.     $0B, $0B, $0B, $0B, $0B, $0B, $0B, $0B,
  142.     $0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D,
  143.     $0E, $0E, $0E, $0E, $0F, $0F, $0F, $0F,
  144.     $10, $10, $10, $10, $11, $11, $11, $11,
  145.     $12, $12, $12, $12, $13, $13, $13, $13,
  146.     $14, $14, $14, $14, $15, $15, $15, $15,
  147.     $16, $16, $16, $16, $17, $17, $17, $17,
  148.     $18, $18, $19, $19, $1A, $1A, $1B, $1B,
  149.     $1C, $1C, $1D, $1D, $1E, $1E, $1F, $1F,
  150.     $20, $20, $21, $21, $22, $22, $23, $23,
  151.     $24, $24, $25, $25, $26, $26, $27, $27,
  152.     $28, $28, $29, $29, $2A, $2A, $2B, $2B,
  153.     $2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F,
  154.     $30, $31, $32, $33, $34, $35, $36, $37,
  155.     $38, $39, $3A, $3B, $3C, $3D, $3E, $3F);
  156.  
  157.  d_len: Array[0..255] of BYTE =
  158.        ($03, $03, $03, $03, $03, $03, $03, $03,
  159.     $03, $03, $03, $03, $03, $03, $03, $03,
  160.     $03, $03, $03, $03, $03, $03, $03, $03,
  161.     $03, $03, $03, $03, $03, $03, $03, $03,
  162.     $04, $04, $04, $04, $04, $04, $04, $04,
  163.     $04, $04, $04, $04, $04, $04, $04, $04,
  164.     $04, $04, $04, $04, $04, $04, $04, $04,
  165.     $04, $04, $04, $04, $04, $04, $04, $04,
  166.     $04, $04, $04, $04, $04, $04, $04, $04,
  167.     $04, $04, $04, $04, $04, $04, $04, $04,
  168.     $05, $05, $05, $05, $05, $05, $05, $05,
  169.     $05, $05, $05, $05, $05, $05, $05, $05,
  170.     $05, $05, $05, $05, $05, $05, $05, $05,
  171.     $05, $05, $05, $05, $05, $05, $05, $05,
  172.     $05, $05, $05, $05, $05, $05, $05, $05,
  173.     $05, $05, $05, $05, $05, $05, $05, $05,
  174.     $05, $05, $05, $05, $05, $05, $05, $05,
  175.     $05, $05, $05, $05, $05, $05, $05, $05,
  176.     $06, $06, $06, $06, $06, $06, $06, $06,
  177.     $06, $06, $06, $06, $06, $06, $06, $06,
  178.     $06, $06, $06, $06, $06, $06, $06, $06,
  179.     $06, $06, $06, $06, $06, $06, $06, $06,
  180.     $06, $06, $06, $06, $06, $06, $06, $06,
  181.     $06, $06, $06, $06, $06, $06, $06, $06,
  182.     $07, $07, $07, $07, $07, $07, $07, $07,
  183.     $07, $07, $07, $07, $07, $07, $07, $07,
  184.     $07, $07, $07, $07, $07, $07, $07, $07,
  185.     $07, $07, $07, $07, $07, $07, $07, $07,
  186.     $07, $07, $07, $07, $07, $07, $07, $07,
  187.     $07, $07, $07, $07, $07, $07, $07, $07,
  188.     $08, $08, $08, $08, $08, $08, $08, $08,
  189.     $08, $08, $08, $08, $08, $08, $08, $08);
  190.  
  191.   getbuf : WORD = 0;
  192.   getlen : BYTE = 0;
  193.   putlen : BYTE = 0;
  194.   putbuf : WORD = 0;
  195.   textsize : longint = 0;
  196.   codesize : longINT = 0;
  197.   printcount : longint = 0;
  198.   match_position : Integer = 0;
  199.   match_length : Integer = 0;
  200.  
  201.  
  202. TYPE
  203.   Freqtype = Array[0..T] OF WORD;
  204.   FreqPtr = ^freqtype;
  205.   PntrType = Array[0..T+N_Char] OF Integer;
  206.   pntrPtr = ^pntrType;
  207.   SonType = Array[0..T] OF Integer;
  208.   SonPtr = ^SonType;
  209.  
  210.  
  211.   TextBufType = Array[0..N+F-1] OF BYTE;
  212.   TBufPtr = ^TextBufType;
  213.   WordRay = Array[0..N+1] OF Integer;
  214.   WordRayPtr = ^WordRay;
  215.   BWordRay = Array[0..N+257] OF Integer;
  216.   BWordRayPtr = ^BWordRay;
  217.  
  218. VAR
  219.   text_buf : TBufPtr;
  220.   lson,dad : WordRayPtr;
  221.   rson : BWordRayPtr;
  222.   freq : FreqPtr;    { cumulative freq table }
  223.  
  224. {
  225.  * pointing parent nodes.
  226.  * area [T..(T + N_CHAR - 1)] are pointers FOR leaves
  227.  }
  228.   prnt : PntrPtr;
  229.  
  230. { pointing children nodes (son[], son[] + 1)}
  231.   son : SonPtr;
  232.  
  233.  
  234.  
  235. Procedure InitTree;  { Initializing tree }
  236.  
  237. VAR
  238.   i : integer;
  239. BEGIN
  240.   FOR i := N + 1 TO N + 256 DO
  241.     rson^[i] := NUL;            { root }
  242.   FOR i := 0 TO N DO
  243.     dad^[i] := NUL;            { node }
  244. END;
  245.  
  246.  
  247.  
  248.  
  249.  
  250. Procedure InsertNode(r : Integer);  { Inserting node to the tree }
  251.  
  252. VAR
  253.   tmp,i, p, cmp : Integer;
  254.   key : TBufPtr;
  255.   c : WORD;
  256.  
  257. BEGIN
  258.      cmp := 1;
  259.      key := @text_buf^[r];
  260.      p := SUCC(N) + key^[0];
  261.      rson^[r] := NUL;
  262.      lson^[r] := NUL;
  263.      match_length := 0;
  264.      WHILE match_length < F DO
  265.        BEGIN
  266.          IF (cmp >= 0) THEN
  267.            BEGIN
  268.          IF (rson^[p] <> NUL) THEN
  269.            p := rson^[p]
  270.          ELSE
  271.                BEGIN
  272.              rson^[p] := r;
  273.          dad^[r] := p;
  274.          exit;
  275.            END;
  276.        END
  277.          ELSE
  278.            BEGIN
  279.          IF (lson^[p] <> NUL) THEN
  280.            p := lson^[p]
  281.          ELSE
  282.                BEGIN
  283.              lson^[p] := r;
  284.          dad^[r] := p;
  285.          exit;
  286.            END;
  287.        END;
  288.          i := 0;
  289.          cmp := 0;
  290.      While (i < F) AND (cmp = 0) DO
  291.            BEGIN
  292.              inc(i);
  293.              cmp := key^[i] - text_buf^[p + i];
  294.            END;
  295.          IF (i > THRESHOLD) THEN
  296.            BEGIN
  297.              tmp := PRED((r - p) AND PRED(N));
  298.          IF (i > match_length) THEN
  299.                BEGIN
  300.              match_position := tmp;
  301.                  match_length := i;
  302.            END;
  303.          IF (match_length < F) AND (i = match_length) THEN
  304.                BEGIN
  305.                  c := tmp;
  306.          IF (c < match_position) THEN
  307.                    match_position := c;
  308.            END;
  309.        END;
  310.        END;                { WHILE TRUE DO }
  311.      dad^[r] := dad^[p];
  312.      lson^[r] := lson^[p];
  313.      rson^[r] := rson^[p];
  314.      dad^[lson^[p]] := r;
  315.      dad^[rson^[p]] := r;
  316.      IF (rson^[dad^[p]] = p) THEN
  317.        rson^[dad^[p]] := r
  318.      ELSE
  319.        lson^[dad^[p]] := r;
  320.      dad^[p] := NUL;  { remove p }
  321. END;
  322.  
  323.  
  324.  
  325.  
  326. Procedure DeleteNode(p: Integer);  { Deleting node from the tree }
  327.  
  328. VAR
  329.   q : Integer;
  330.  
  331. BEGIN
  332.   IF (dad^[p] = NUL) THEN
  333.     exit;            { unregistered }
  334.   IF (rson^[p] = NUL) THEN
  335.     q := lson^[p]
  336.   ELSE IF (lson^[p] = NUL) THEN
  337.     q := rson^[p]
  338.   ELSE
  339.     BEGIN
  340.       q := lson^[p];
  341.       IF (rson^[q] <> NUL) THEN
  342.         BEGIN
  343.       REPEAT
  344.             q := rson^[q];
  345.       UNTIL (rson^[q] = NUL);
  346.           rson^[dad^[q]] := lson^[q];
  347.       dad^[lson^[q]] := dad^[q];
  348.       lson^[q] := lson^[p];
  349.       dad^[lson^[p]] := q;
  350.     END;
  351.       rson^[q] := rson^[p];
  352.       dad^[rson^[p]] := q;
  353.     END;
  354.   dad^[q] := dad^[p];
  355.   IF (rson^[dad^[p]] = p) THEN
  356.     rson^[dad^[p]] := q
  357.   ELSE
  358.     lson^[dad^[p]] := q;
  359.   dad^[p] := NUL;
  360. END;
  361.  
  362.  
  363. { Huffman coding parameters }
  364.  
  365.  
  366. Function GetBit(GetBytes:GetBytesProc): Integer;    { get one bit }
  367. VAR
  368.   i: BYTE;
  369.   i2 : Integer;
  370.   result : Word;
  371.  
  372. BEGIN
  373.   WHILE (getlen <= 8) DO
  374.     BEGIN
  375.       GetBytes(i,1,Result);
  376.       If Result = 1 THEN
  377.         i2 := i
  378.       ELSE i2 := 0;
  379.       getbuf := getbuf OR (i2 SHL (8 - getlen));
  380.       INC(getlen,8);
  381.     END;
  382.   i2 := getbuf;
  383.   getbuf := getbuf SHL 1;
  384.   DEC(getlen);
  385.   getbit := INTEGER((i2 < 0));
  386. END;
  387.  
  388.  
  389.  
  390.  
  391. Function GetByte(GetBytes:GetBytesProc): Integer;    { get a byte }
  392.  
  393. VAR
  394.   j : BYTE;
  395.   i,result : WORD;
  396. BEGIN
  397.   WHILE (getlen <= 8) DO
  398.     BEGIN
  399.       GetBytes(j,1,result);
  400.       If Result = 1 THEN
  401.         i := j
  402.       ELSE
  403.         i := 0;
  404.       getbuf := getbuf OR (i SHL (8 - getlen));
  405.       INC(getlen,8);
  406.     END;
  407.   i := getbuf;
  408.   getbuf := getbuf SHL 8;
  409.   DEC(getlen,8);
  410.   getbyte := integer(i SHR 8);
  411. END;
  412.  
  413.  
  414.  
  415.  
  416.  
  417. PROCEDURE Putcode(l : Integer; c: WORD;PutBytes:PutBytesProc);        { output c bits }
  418. VAR
  419.   Temp : BYTE;
  420.   Got : WORD;
  421. BEGIN
  422.   putbuf := putbuf OR (c SHR putlen);
  423.   inc(putlen,l);
  424.   IF (putlen >= 8) THEN
  425.     BEGIN
  426.       Temp := putbuf SHR 8;
  427.       PutBytes(Temp,1,Got);
  428.       DEC(putlen,8);
  429.       IF (putlen  >= 8) THEN
  430.         BEGIN
  431.           Temp := Lo(PutBuf);
  432.       PutBytes(Temp,1,Got);
  433.       INC(codesize,2);
  434.       DEC(putlen,8);
  435.       putbuf := c SHL (l - putlen);
  436.     END
  437.       ELSE
  438.         BEGIN
  439.       putbuf := putbuf SHL 8;
  440.       INC(codesize);
  441.     END;
  442.     END;
  443. END;
  444.  
  445.  
  446.  
  447. { initialize freq tree }
  448.  
  449. Procedure StartHuff;
  450. VAR
  451.   i, j : Integer;
  452. BEGIN
  453.   FOR i := 0 to PRED(N_CHAR) DO
  454.     BEGIN
  455.       freq^[i] := 1;
  456.       son^[i] := i + T;
  457.       prnt^[i + T] := i;
  458.     END;
  459.   i := 0;
  460.   j := N_CHAR;
  461.   WHILE (j <= R) DO
  462.     BEGIN
  463.       freq^[j] := freq^[i] + freq^[i + 1];
  464.       son^[j] := i;
  465.       prnt^[i] := j;
  466.       prnt^[i + 1] := j;
  467.       INC(i,2);
  468.       INC(j);
  469.     END;
  470.   freq^[T] := $ffff;
  471.   prnt^[R] := 0;
  472. END;
  473.  
  474.  
  475.  
  476.  
  477. { reconstruct freq tree }
  478.  
  479. PROCEDURE reconst;
  480. VAR
  481.  i, j, k, tmp : Integer;
  482.  f, l : WORD;
  483. BEGIN
  484.  { halven cumulative freq FOR leaf nodes }
  485.   j := 0;
  486.   FOR i := 0 to PRED(T) DO
  487.     BEGIN
  488.       IF (son^[i] >= T) THEN
  489.         BEGIN
  490.       freq^[j] := SUCC(freq^[i]) MOD 2;
  491.       son^[j] := son^[i];
  492.       INC(j);
  493.     END;
  494.     END;
  495.   { make a tree : first, connect children nodes }
  496.   i := 0;
  497.   j := N_CHAR;
  498.   WHILE (j < T) DO
  499.     BEGIN
  500.       k := SUCC(i);
  501.       f := freq^[i] + freq^[k];
  502.       freq^[j] := f;
  503.       k := PRED(j);
  504.       WHILE f < freq^[k] DO
  505.         DEC(K);
  506.       INC(k);
  507.       l := (j - k) SHL 1;
  508.       tmp := SUCC(k);
  509.       move(freq^[k], freq^[tmp], l);
  510.       freq^[k] := f;
  511.       move(son^[k], son^[tmp], l);
  512.       son^[k] := i;
  513.       INC(i,2);
  514.       INC(j);
  515.     END;
  516.         { connect parent nodes }
  517.   FOR i := 0 to PRED(T) DO
  518.     BEGIN
  519.       k := son^[i];
  520.       IF (k >= T) THEN
  521.         BEGIN
  522.       prnt^[k] := i;
  523.     END
  524.       ELSE
  525.         BEGIN
  526.       prnt^[k] := i;
  527.           prnt^[SUCC(k)] := i;
  528.     END;
  529.     END;
  530. END;
  531.  
  532.  
  533. { update freq tree }
  534.  
  535. Procedure update(c : Integer);
  536. VAR
  537.   i, j, k, l : Integer;
  538. BEGIN
  539.   IF (freq^[R] = MAX_FREQ) THEN
  540.     BEGIN
  541.       reconst;
  542.     END;
  543.   c := prnt^[c + T];
  544.   REPEAT
  545.     INC(freq^[c]);
  546.     k := freq^[c];
  547.  
  548.     { swap nodes to keep the tree freq-ordered }
  549.    l := SUCC(C);
  550.    IF (k > freq^[l]) THEN
  551.      BEGIN
  552.        WHILE (k > freq^[l]) DO
  553.          INC(l);
  554.        DEC(l);
  555.        freq^[c] := freq^[l];
  556.        freq^[l] := k;
  557.  
  558.        i := son^[c];
  559.        prnt^[i] := l;
  560.        IF (i < T) THEN prnt^[SUCC(i)] := l;
  561.  
  562.        j := son^[l];
  563.        son^[l] := i;
  564.  
  565.        prnt^[j] := c;
  566.        IF (j < T) THEN prnt^[SUCC(j)] := c;
  567.        son^[c] := j;
  568.  
  569.        c := l;
  570.      END;
  571.    c := prnt^[c];
  572.  UNTIL (c = 0);    { REPEAT it until reaching the root }
  573. END;
  574.  
  575.  
  576. VAR
  577.   code, len : WORD;
  578.  
  579.  
  580.  
  581.  
  582. PROCEDURE EncodeChar(c: WORD;PutBytes:PutBytesProc);
  583. VAR
  584.   i : WORD;
  585.   j, k : Integer;
  586. BEGIN
  587.   i := 0;
  588.   j := 0;
  589.   k := prnt^[c + T];
  590.  
  591.     { search connections from leaf node to the root }
  592.   REPEAT
  593.     i := i SHR 1;
  594.  
  595.     {
  596.     IF node's address is odd, output 1
  597.     ELSE output 0
  598.     }
  599.     IF BOOLEAN(k AND 1) THEN INC(i,$8000);
  600.     INC(j);
  601.     k := prnt^[k];
  602.   UNTIL (k = R);
  603.   Putcode(j, i,PutBytes);
  604.   code := i;
  605.   len := j;
  606.   update(c);
  607. END;
  608.  
  609.  
  610.  
  611. Procedure EncodePosition(c : WORD;PutBytes:PutBytesProc);
  612. VAR
  613.   i,j : WORD;
  614. BEGIN
  615.     { output upper 6 bits with encoding }
  616.   i := c SHR 6;
  617.   j := p_code[i];
  618.   Putcode(p_len[i],j SHL 8,PutBytes);
  619.  
  620.     { output lower 6 bits directly }
  621.   Putcode(6, (c AND $3f) SHL 10,PutBytes);
  622. END;
  623.  
  624.  
  625.  
  626. Procedure EncodeEnd(PutBytes:PutBytesProc);
  627. VAR
  628.   Temp : BYTE;
  629.   Got : WORD;
  630. BEGIN
  631.   IF BOOLEAN(putlen) THEN
  632.     BEGIN
  633.       Temp := Lo(putbuf SHR 8);
  634.       PutBytes(Temp,1,Got);
  635.       INC(codesize);
  636.     END;
  637. END;
  638.  
  639.  
  640.  
  641.  
  642.  
  643. FUNCTION DecodeChar(GetBytes:GetBytesProc): Integer;
  644. VAR
  645.   c : WORD;
  646. BEGIN
  647.   c := son^[R];
  648.  
  649.     {
  650.      * start searching tree from the root to leaves.
  651.      * choose node #(son[]) IF input bit = 0
  652.      * ELSE choose #(son[]+1) (input bit = 1)
  653.     }
  654.   WHILE (c < T) DO
  655.     BEGIN
  656.       c := c + GetBit(GetBytes);
  657.       c := son^[c];
  658.     END;
  659.   c := c - T;
  660.   update(c);
  661.   Decodechar := Integer(c);
  662. END;
  663.  
  664.  
  665.  
  666.  
  667.  
  668. Function DecodePosition(GetBytes:GetBytesProc) : WORD;
  669. VAR
  670.   i, j, c : WORD;
  671. BEGIN
  672.      { decode upper 6 bits from given table }
  673.   i := GetByte(GetBytes);
  674.   c := WORD(d_code[i] SHL 6);
  675.   j := d_len[i];
  676.  
  677.     { input lower 6 bits directly }
  678.   DEC(j,2);
  679.   While j <> 0 DO
  680.     BEGIN
  681.       i := (i SHL 1) + GetBit(GetBytes);
  682.       DEC(J);
  683.     END;
  684.   DecodePosition := c OR i AND $3f;
  685. END;
  686.  
  687.  
  688.  
  689. { Compression }
  690.  
  691.  
  692.  
  693. Procedure InitLZH;
  694. BEGIN
  695.   getbuf := 0;
  696.   getlen := 0;
  697.   putlen := 0;
  698.   putbuf := 0;
  699.   textsize := 0;
  700.   codesize := 0;
  701.   printcount := 0;
  702.   match_position := 0;
  703.   match_length := 0;
  704.   New(lson);
  705.   New(dad);
  706.   New(rson);
  707.   New(text_buf);
  708.   New(freq);
  709.   New(prnt);
  710.   New(son);
  711. END;
  712.  
  713.  
  714. Procedure EndLZH;
  715.  
  716. BEGIN
  717.   Dispose(son);
  718.   Dispose(prnt);
  719.   Dispose(freq);
  720.   Dispose(text_buf);
  721.   Dispose(rson);
  722.   Dispose(dad);
  723.   Dispose(lson);
  724. END;
  725.  
  726.  
  727. Procedure LZHPack(VAR Bytes_Written:LongInt; GetBytes:GetBytesProc; PutBytes:PutBytesProc);
  728. VAR
  729.    ct : BYTE;
  730.    i, len, r, s, last_match_length : Integer;
  731.    Got : WORD;
  732. BEGIN
  733.   InitLZH;
  734.  
  735.   textsize := 0;            { rewind and rescan }
  736.   StartHuff;
  737.   InitTree;
  738.   s := 0;
  739.   r := N - F;
  740.   FillChar(Text_buf^[0],r,' ');
  741.   len := 0;
  742.   Got := 1;
  743.   While (len < F) AND (Got <> 0) DO
  744.     BEGIN
  745.       GetBytes(ct,1,Got);
  746.       IF Got <> 0 THEN
  747.         BEGIN
  748.           text_buf^[r + len] := ct;
  749.           INC(len);
  750.         END;
  751.     END;
  752.   textsize := len;
  753.   FOR i := 1 to F DO
  754.     InsertNode(r - i);
  755.   InsertNode(r);
  756.   REPEAT
  757.     IF (match_length > len) THEN
  758.       match_length := len;
  759.     IF (match_length <= THRESHOLD) THEN
  760.       BEGIN
  761.         match_length := 1;
  762.     EncodeChar(text_buf^[r],PutBytes);
  763.       END
  764.     ELSE
  765.       BEGIN
  766.         EncodeChar(255 - THRESHOLD + match_length,PutBytes);
  767.     EncodePosition(match_position,PutBytes);
  768.       END;
  769.     last_match_length := match_length;
  770.     i := 0;
  771.     Got := 1;
  772.     While (i < last_match_length) AND (Got <> 0) DO
  773.       BEGIN
  774.         GetBytes(ct,1,Got);
  775.         IF Got <> 0 THEN
  776.           BEGIN
  777.             DeleteNode(s);
  778.         text_buf^[s] := ct;
  779.           IF (s < PRED(F)) THEN
  780.           text_buf^[s + N] := ct;
  781.         s := SUCC(s) AND PRED(N);
  782.         r := SUCC(r) AND PRED(N);
  783.         InsertNode(r);
  784.             inc(i);
  785.           END;
  786.       END;
  787.     INC(textsize,i);
  788.     While (i < last_match_length) DO
  789.       BEGIN
  790.         INC(i);
  791.         DeleteNode(s);
  792.         s := SUCC(s) AND PRED(N);
  793.         r := SUCC(r) AND PRED(N);
  794.         DEC(len);
  795.         IF BOOLEAN(len) THEN InsertNode(r);
  796.       END;
  797.   UNTIL (len <= 0);
  798.   EncodeEnd(PutBytes);
  799.   EndLZH;
  800.   Bytes_Written := TextSize;
  801. END;
  802.  
  803.  
  804.  
  805.  
  806. Procedure LZHUnpack(TextSize : Longint; GetBytes:GetBytesProc; PutBytes: PutBytesProc);
  807. VAR
  808.   c, i, j, k, r : Integer;
  809.   c2,a : Byte;
  810.   count : Longint;
  811.   Put : Word;
  812.  
  813. BEGIN
  814.   InitLZH;
  815.   StartHuff;
  816.   r := N - F;
  817.   FillChar(text_buf^[0],r,' ');
  818.   Count := 0;
  819.   While count < textsize DO
  820.     BEGIN
  821.       c := DecodeChar(GetBytes);
  822.       IF (c < 256) THEN
  823.         BEGIN
  824.           c2 := Lo(c);
  825.       PutBytes(c2,1,Put);
  826.       text_buf^[r] := c;
  827.           INC(r);
  828.       r := r AND PRED(N);
  829.       INC(count);
  830.     END
  831.       ELSE
  832.         BEGIN
  833.       i := (r - SUCC(DecodePosition(GetBytes))) AND PRED(N);
  834.       j := c - 255 + THRESHOLD;
  835.       FOR k := 0 TO PRED(j) DO
  836.             BEGIN
  837.           c := text_buf^[(i + k) AND PRED(N)];
  838.               c2 := Lo(c);
  839.           PutBytes(c2,1,Put);
  840.           text_buf^[r] := c;
  841.               INC(r);
  842.           r := r AND PRED(N);
  843.           INC(count);
  844.         END;
  845.     END;
  846.     END;
  847.   ENDLZH;
  848. END;
  849.  
  850.  
  851. END.
  852.